perm filename FILLMS.F4[MSS,LCS]8 blob
sn#140163 filedate 1975-01-11 generic text, type T, neo UTF8
00010 C**** CHANGE 1, 2 AND 3 TO JFCL IN DDT WHEN USING DISTORTION.(SEE 'LINES')
00100 SUBROUTINE FILLMS(L,IDAT,RJB,CENTR,RJF,RJG)
00110 COMMON/DPY/ST(4000),WDS(250),MEDIT,IGO/DL/RSIZ,SAVER,NAME
00120 COMMON/DST/BB,CC/FLM/X(200),Y(200),NX(200)
00130 COMMON/ALF/INP(65),DX,RX,D,R,C,KK,J,ML
00200 DIMENSION IDAT(1)
00220 COMMON/PLTR/IPLT,RHT,DIS/LL/LL/STF/RR(8),RSTJC
00222 INTEGER XGP
00225 DATA XGP/2/,MD/6/
00227 C MD=DISPLAY CHANGE XGP TO 1 IN DDT WHEN PLOTTING ON XGP!
00230 DX=DIS
00240 RX=RHT
00270 D=RSTJC*RJF
00280 R=RSTJC*RJG
00400 1 GO TO 10
00450 C=CC
00460 B=BB
00500 C SAVES IT. IT WILL RETURN LATER.
00525 BB=B/DIS
00550 CC=1000
00600 10 KK=0
00700 DO 205 J=1,L
00800 CALL UNPACK(M,N,IDAT(J))
00900 KK=KK+1
01000 NX(KK)=0
01100 IF(LL.EQ.3)NX(KK)=3
01200 X(KK)=ROFF((RJB+D*M)*DIS)
01300 Y(KK)=ROFF((CENTR+R*N)*RHT)
01310 2 GO TO 205
01320 Y(KK)=Y(KK)*(C-BB*(ABS(X(KK))))
01330 C FOR DISTORTION
01340 205 CONTINUE
01400 NX(1)=KK
01410 DIS=1.0
01420 RHT=DIS
01500 M=MD
01600 CC IF(IPLT)M=MP-IXRX
01610 IF(IPLT.GE.0)GO TO 20
01615 M=RSIZ+.4
01620 IF(M.LE.0)M=1
01630 IF(M.GT.XGP)M=XGP
01650 C STOPS DISTORTION IN 'LINES'
01700 20 CALL FILLER(X,Y,NX,M)
01710 DIS=DX
01720 RHT=RX
01730 3 RETURN
01740 C NEXT TO RESET DISTORTION FACT.
01745 BB=B
01750 CC=C
01800 END
01900
02000 SUBROUTINE ROTATE(I,L)
02100 DIMENSION I(1)
02105 COMMON/LL/LL
02110 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/STF/RR(8),RSTJC
02155 EQUIVALENCE (RJF,RJQ(4)),(RJG,RJQ(5)),(DEG,RJQ(7))
02190 RJG=RJG*RSTJC
02195 RJF=RJF*RSTJC
02200 N=I(L)
02225 KNT=601
02250 C ROTATED DATA IS PUT BACK STARTING AT LOCATION 601.
02275 I(KNT)=N
02300 DO 1 K=L+1,N+L-1
02400 CALL UNPACK(J,M,I(K))
02500 X=J*RJF
02600 Y=M*RJG
02700 JJ=I(K)/100000000
02800 AX=ATAN2(X,Y)*57.29578
02900 HYP=SQRT(X**2+Y**2)
03000 ROT=DEG+AX
03100 J=ROFF(HYP*COSD(ROT))
03200 M=ROFF(HYP*SIND(ROT))
03300 KNT=KNT+1
03400 IF(J)J=1000-J
03500 IF(M)M=1000-M
03600 1 I(KNT)=M*10000+J+JJ*100000000
03700 L=601
03800 RJF=1.
03900 RJG=1.
04000 RSTJC=1.
04100 C SIZE CHANGES MUST BE MADE BEFORE ROTATION!!!!! ELSE IT DISTORTS.
04200 END